#lang scheme/base

(require (planet "evector.scm" ("soegaard" "evector.plt" 1))
         srfi/13/string
         (except-in scheme/list empty last)
         scheme/match
         scheme/math
         "../../debug.ss"
         "../syntax/regexps.ss"
         "exceptions.ss"
         "value.ss"
         "runtime.ss"
         (only-in racket/string string-append*)
         (only-in racket/base regexp-split))

;; TODO: abstract out the conveniences like install-properties! into a separate module
(provide install-standard-library! install-standard-library-once! install-properties! reset-global-object! reset-primitive-constructors!)

(define (object-descriptor object)
  (format "[object ~a]" (object-class object)))

(define js:print
  (build-function 1
                  (lambda args
                    (let ([print1 (lambda (x)
                                    (display (any->string x)))])
                      (unless (null? args)
                        (print1 (car args))
                        (for-each (lambda (arg)
                                    (display " ")
                                    (print1 arg))
                                  (cdr args)))
                      (newline)))))

(define js:parseInt
  (build-function 2
                  (lambda ([string (void)] [radix (void)] . _)
                    (let* ([s (string-trim (any->string string) char-whitespace?)]
                           [r (any->int32 radix)]
                           [sign (if (char=? (string-ref s 0) #\-)
                                     (begin (set! s (substring s 1)) -1)
                                     1)])
                      (if (or (and (not (zero? r)) (< r 2))
                              (> r 36))
                          +nan.0
                          (let ([r (cond
                                     [(or (string-prefix? "0x" s) (string-prefix? "0X" s))
                                      (set! s (substring s 2))
                                      16]
                                     [(string-prefix? "0" s)
                                      (set! s (substring s 1))
                                      8]
                                     [(zero? r)
                                      10]
                                     [else r])])
                            (cond
                              [(regexp-match (build-integer-regexp r) s)
                               => (lambda (match)
                                    (let sum ([factor 1]
                                              [total 0]
                                              [digits (map char->digit (reverse (string->list (car match))))])
                                      (if (null? digits)
                                          total
                                          (sum (* factor r)
                                               (+ total (* (car digits) factor))
                                               (cdr digits)))))]
                              [else +nan.0])))))))

(define (char->digit ch)
  (cond
    [(memv ch (string->list "0123456789"))
     (- (char->integer ch) (char->integer #\0))]
    [(memv ch (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
     (- (char->integer ch) (char->integer #\A))]
    [(memv ch (string->list "abcdefghijklmnopqrstuvwxyz"))
     (- (char->integer ch) (char->integer #\a))]
    [else
     (error 'char->digit "bad digit: ~a" ch)]))

(define (build-integer-regexp base)
  (regexp
   (cond
     [(<= base 10)
      (format "^[0-~a]+" (sub1 base))]
     [(= base 11)
      "^[0-9Aa]+"]
     [else
      (let ([last-char-index (- base 11)])
        (format "^[0-9A-~aa-~a]+"
                (string-ref "ABCDEFGHIJKLMNOPQRSTUVWXYZ" last-char-index)
                (string-ref "abcdefghijklmnopqrstuvwxyz" last-char-index)))])))

;; 15.1.2.3
(define js:parseFloat
  (build-function 1
                  (lambda ([arg (void)] . _)
                    (let ([s (string-trim (any->string arg)
                                          char-whitespace?)])
                      (cond
                        [(regexp-match rx:float s)
                         => (lambda (match)
                              ;; TODO: calculate the MV according to 9.3.1
                              (string->number (car match)))]
                        [else +nan.0])))))

(define js:isNaN
  (build-function 1
                  (lambda ([arg (void)] . _)
                    (NaN? (any->number arg)))))

(define js:isFinite
  (build-function 1
                  (lambda ([arg (void)] . _)
                    (let ([x (any->number arg)])
                      (and (not (NaN? x))
                           (not (infinite? x)))))))

(define js:eval
  (build-function 1
                  (lambda args
                    (raise-runtime-exception here "indirect eval"))))

(define (tmp:stub arity name)
  (build-function arity
                  (lambda args
                    (error name "not yet implemented"))))

(define js:decodeURI (tmp:stub 1 'decodeURI))
(define js:decodeURIComponent (tmp:stub 1 'decodeURIComponent))
(define js:encodeURI (tmp:stub 1 'encodeURI))
(define js:encodeURIComponent (tmp:stub 1 'encodeURIComponent))

(define (reset-object! object)
  (set-object-properties! object (object-table))
  (set-ref! eval-ref js:eval))

(define (reset-global-object! global)
  (reset-object! global)
  (reset-object! proto:global) ;; TODO: get this from (object-proto global) instead?
  (reset-object! proto:proto)
  
  (object-put! proto:proto 'write (build-function 1
                                                  (lambda args
                                                    (write (object-descriptor (current-this)) (if (null? args) (current-output-port) (car args))))))
  (object-put! proto:proto 'display (build-function 1
                                                    (lambda args
                                                      (display (object-descriptor (current-this)) (if (null? args) (current-output-port) (car args))))))
  (object-put! proto:global 'toString (build-function 0
                                                      (lambda args
                                                        (object-descriptor (current-this)))))
  (object-put! proto:global 'hasOwnProperty (build-function 1
                                                            (lambda args
                                                              (has-own-property? (current-this)
                                                                                 (any->property-name (get-arg args 0)))))))

(define (reset-primitive-constructors! global)
  (for ([ctor (list Object Function Array String Boolean Number Trace Name)]
        [proto (list proto:Object proto:Function proto:Array proto:String proto:Boolean proto:Number proto:Trace proto:Name)]
        [name '(Object Function Array String Boolean Number Trace Name)])
    (reset-object! proto)
    (reset-object! ctor)
    ;; 15.2.3.1, 15.3.3.1, 15.4.3.1, 15.5.3.1, 15.6.3.1, 15.7.3.1
    (object-put! ctor 'prototype proto (bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15, 15.2.3, 15.3.3, 15.4.3, 15.5.3, 15.6.3, 15.7.3
    (object-put! ctor 'length 1 (bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))                
    ;; 15?
    (object-put! global name ctor (bit-field DONT-ENUM? DONT-DELETE?))
    ;; 15.2.4.1, 15.3.4.1, 15.4.4.1, 15.5.4.1, 15.6.4.1, 15.7.4.1
    (object-put! proto 'constructor ctor))
  (reset-object! Math)
  (object-put! global 'Math Math (bit-field DONT-ENUM? DONT-DELETE?)))

(define Object-methods
  `(;; 15.2.4.2
    (toString           ,(build-function 0
                                         (lambda args
                                           (object-descriptor (current-this)))))
    ;; 15.2.4.3
    (toLocaleString     ,(build-function 0
                                         (lambda args
                                           (let ([toString (object-get (current-this) 'toString (lambda ()
                                                                                                  (raise-runtime-type-error here "function" "undefined")))])
                                             (apply toString args)))))
    ;; 14.2.4.4
    (valueOf            ,(build-function 0
                                         (lambda args
                                           (current-this))))
    ;; 15.2.4.5
    (hasOwnProperty     ,(build-function 0
                                         (lambda args
                                           (has-own-property? (current-this)
                                                              (any->property-name (get-arg args 0))))))
    ;; 15.2.4.6
    (isPrototypeOf      ,(build-function 1
                                         (lambda args
                                           (let ([O (current-this)]
                                                 [V (if (null? args) (void) (car args))])
                                             (and (object? V)
                                                  (let loop ([V (object-proto V)])
                                                    (and V (or (eq? O V)
                                                               (loop (object-proto V))))))))))
    ;; 15.2.4.7
    (propertyIsEnumerable ,(build-function 1
                                           (lambda args
                                             (let ([O (current-this)]
                                                   [V (any->property-name (if (null? args) (void) (car args)))])
                                               (and (has-own-property? O V)
                                                    (not (bit-flag-set? (object-get-attributes O V) DONT-ENUM?)))))))
    ))

(define Function-methods
  `(;; 15.3.4.2
    (toString           ,(build-function 0
                                         (lambda args
                                           (unless (descendant-of? (current-this) proto:Function)
                                             (raise-runtime-type-error here "function" "object"))
                                           ;; TODO: show function source
                                           "[object Function]")))
    ;; 15.3.4.3
    (apply              ,(tmp:stub 2 "apply"))
    ;; 15.3.4.4
    (call               ,(tmp:stub 1 "call"))
    ))

;; NOTE: according to Brendan this is a bug in the spec and no one adheres to it
(define (as-if-by-new-Array)
  (new-Array))
;  (let* ([obj (object-get global-object "Array" (lambda ()
;                                                  (raise-runtime-exception here "Array undefined")))] ;; TODO: can't happen? (DONT-DELETE)
;         [ctor (or (and (function? obj) (function-construct obj))
;                   (and (object? obj) (raise-runtime-type-error here "constructor" "object"))
;                   (raise-runtime-type-error here "constructor" "primitive"))])
;    (ctor)))

(define Array-methods
  `((write              ,(build-function 1
                                         (lambda args
                                           (let ([this (current-this)]
                                                 [out (if (null? args) (current-output-port) (car args))])
                                             (for ([i (in-range (object-get this 'length (lambda () 0) any->uint32))])
                                               (when (> i 0)
                                                 (display "," out))
                                               (object-get this (any->string i) void (lambda (x) (write x out))))))))
    (display            ,(build-function 1
                                         (lambda args
                                           (let ([this (current-this)]
                                                 [out (if (null? args) (current-output-port) (car args))])
                                             (for ([i (in-range (object-get this 'length (lambda () 0) any->uint32))])
                                               (when (> i 0)
                                                 (display "," out))
                                               (object-get this (any->property-name i) void (lambda (x) (display x out))))))))
    ;; 15.4.4.2
    (toString           ,(build-function 0
                                         (lambda args
                                           (let ([this (current-this)])
                                             (string-join (for/list ([i (in-range (object-get this 'length (lambda () 0) any->uint32))])
                                                            (object-get this (any->property-name i) (lambda () "") any->string))
                                                          ","
                                                          'infix)))))
    ;; 15.4.4.3
    (toLocaleString     ,(build-function 0
                                         (lambda args
                                           (let ([this (current-this)])
                                             (unless (descendant-of? this proto:Array)
                                               (raise-runtime-type-error here "array" "object"))
                                             (string-join (for/list ([i (in-range (object-get this 'length (lambda () 0) any->uint32))])
                                                            (object-get this
                                                                        (any->string i)
                                                                        (lambda () "")
                                                                        (lambda (v)
                                                                          (invoke (any->object v)
                                                                                  'toLocaleString
                                                                                  '()
                                                                                  (lambda (s1 s2)
                                                                                    (raise-runtime-type-error here s1 s2))))))
                                                          ;                                              (let ([v (object-get this (any->string i))])
                                                          ;                                                (if v
                                                          ;                                                    (invoke (any->object v)
                                                          ;                                                            "toLocaleString"
                                                          ;                                                            '()
                                                          ;                                                            (lambda (s1 s2)
                                                          ;                                                              (raise-runtime-type-error here s1 s2)))
                                                          ;                                                    "")))
                                                          ;; TODO: use locale info to choose separator
                                                          ","
                                                          'infix)))))
    ;; 15.4.4.4
    (concat             ,(build-function 1
                                         (lambda args
                                           (let ([this (current-this)]
                                                 [A (as-if-by-new-Array)])
                                             ;; (listof value) * nat -> nat
                                             (define (copy-arrays arrays n)
                                               (if (pair? arrays)
                                                   (let ([E (car arrays)])
                                                     ;; nat * nat * nat -> nat
                                                     (define (copy-array Result6 n k)
                                                       (if (= k Result6)
                                                           (copy-arrays (cdr arrays) n)
                                                           (let ([Result8 (any->property-name k)])
                                                             (when (has-property? E Result8)
                                                               (object-put! A (any->string n) (object-get E Result8)))
                                                             (copy-array Result6 (add1 n) (add1 k)))))
                                                     (if (array? E)
                                                         (copy-array (object-get E 'length) n 0)
                                                         (begin (object-put! A n E)
                                                                (copy-arrays (cdr arrays) (add1 n)))))
                                                   n))
                                             (object-put! A "length" (copy-arrays (cons this args) 0))
                                             A))))
    ;; 15.4.4.5
    (join               ,(build-function 1
                                         (lambda args
                                           (let ([this (current-this)])
                                             (string-join (for/list ([i (in-range (object-get this 'length (lambda () 0) any->uint32))])
                                                            (object-get this
                                                                        (any->property-name i)
                                                                        (lambda () "")
                                                                        (lambda (v)
                                                                          (if (or (void? v) (null? v)) "" (any->string v)))))
                                                          (or (and (pair? args) (any->string (car args)))
                                                              ",")
                                                          'infix)))))
    ;; 15.4.4.6
    (pop                ,(build-function 0
                                         (lambda args
                                           (let ([this (current-this)])
                                             (let ([len (object-get this 'length (lambda () 0) any->uint32)])
                                               (if (zero? len)
                                                   (begin (object-put! this 'length len) (void))
                                                   (let* ([key (any->property-name (sub1 len))]
                                                          [val (object-get this key void)])
                                                     (object-delete! this key)
                                                     (object-put! this "length" (sub1 len))
                                                     val)))))))
    ;; 15.4.4.7
    (push               ,(build-function 1
                                         (lambda args
                                           (let ([this (current-this)])
                                             (let* ([len (object-get this 'length (lambda () 0) any->uint32)]
                                                    [new-len (+ len (length args))])
                                               (for ([arg args]
                                                     [n (in-range len new-len)])
                                                 (object-put! this (any->property-name n) arg))
                                               (object-put! this 'length new-len)
                                               new-len)))))
    ;; 15.4.4.8
    (reverse            ,(build-function 0
                                         (lambda args
                                           (let ([this (current-this)])
                                             (let* ([len (object-get this 'length (lambda () 0) any->uint32)]
                                                    [half (floor (/ len 2))])
                                               (define (loop left)
                                                 (if (= left half)
                                                     this
                                                     (let* ([right (sub1 (- len left))]
                                                            [left-key (any->property-name left)]
                                                            [right-key (any->property-name right)])
                                                       (object-get this
                                                                   left-key
                                                                   (lambda ()
                                                                     (object-get this
                                                                                 right-key
                                                                                 (lambda ()
                                                                                   (object-delete! this left-key)
                                                                                   (object-delete! this right-key))
                                                                                 (lambda (right-val)
                                                                                   (object-delete! this right-key)
                                                                                   (object-put! this left-key right-val))))
                                                                   (lambda (left-val)
                                                                     (object-get this
                                                                                 right-key
                                                                                 (lambda ()
                                                                                   (object-put! this right-key left-val)
                                                                                   (object-delete! this right-key))
                                                                                 (lambda (right-val)
                                                                                   (object-put! this left-key right-val)
                                                                                   (object-put! this right-key left-val)))))
                                                       ;                                         (cond
                                                       ;                                           [(object-get this left-key)
                                                       ;                                            => (lambda (left-val)
                                                       ;                                                 (cond
                                                       ;                                                   [(object-get this right-key)
                                                       ;                                                    => (lambda (right-val)
                                                       ;                                                         (object-put! this left-key right-val)
                                                       ;                                                         (object-put! this right-key left-val))]
                                                       ;                                                   [else
                                                       ;                                                    (object-put! this right-key left-val)
                                                       ;                                                    (object-delete! this right-key)]))]
                                                       ;                                           [(object-get this right-key)
                                                       ;                                            => (lambda (right-val)
                                                       ;                                                 (object-delete! this right-key)
                                                       ;                                                 (object-put! this left-key right-val))]
                                                       ;                                           [else
                                                       ;                                            (object-delete! this left-key)
                                                       ;                                            (object-delete! this right-key)])
                                                       (loop (add1 left)))))
                                               (loop 0))))))
    ;; 15.4.4.9
    (shift              ,(build-function 0
                                         (lambda args
                                           (let ([this (current-this)])
                                             (let ([len (object-get this 'length (lambda () 0) any->uint32)])
                                               (if (zero? len)
                                                   (begin (object-put! this 'length len) (void))
                                                   (let ([removed (object-get this "0")])
                                                     (define (loop k)
                                                       (if (= k len)
                                                           (begin (object-delete! this (any->property-name (sub1 len)))
                                                                  (object-put! this 'length (sub1 len))
                                                                  removed)
                                                           (let ([k-key (any->property-name k)]
                                                                 [k-1-key (any->property-name (sub1 k))])
                                                             (object-get this
                                                                         k-key
                                                                         (lambda ()
                                                                           (object-delete! this k-1-key))
                                                                         (lambda (val)
                                                                           (object-put! this k-1-key val)))
                                                             ;                                               (cond
                                                             ;                                                 [(object-get this k-key)
                                                             ;                                                  => (lambda (val)
                                                             ;                                                       (object-put! this k-1-key val))]
                                                             ;                                                 [else (object-delete! this k-1-key)])
                                                             (loop (add1 k)))))
                                                     (loop 0))))))))
    ;; 15.4.4.10
    (slice              ,(build-function 2
                                         (lambda args
                                           (let* ([this (current-this)]
                                                  [len (object-get this 'length (lambda () 0) any->uint32)]
                                                  [A (as-if-by-new-Array)])
                                             (define (any->index x)
                                               (let ([int (any->integer x)])
                                                 (if (negative? int)
                                                     (max (+ len int) 0)
                                                     (min int len))))
                                             (let-values ([(start end) (match args
                                                                         [(list) (values (any->index (void))
                                                                                         (any->index (void)))]
                                                                         [(list start) (values (any->index start)
                                                                                               (any->index (void)))]
                                                                         [(list start end _ ...) (values (any->index start)
                                                                                                         (any->index end))])])
                                               (define (loop k n)
                                                 (if (>= k end)
                                                     (object-put! A 'length n)
                                                     (let ([k-key (any->property-name k)])
                                                       (when (has-property? this k-key)
                                                         (object-put! A (any->property-name n) (object-get this k-key)))
                                                       (loop (add1 k) (add1 n)))))
                                               (loop start 0)
                                               A)))))
    ;; 15.4.4.11
    (sort               ,(build-function 1
                                         (lambda args
                                           (let ([this (current-this)]
                                                 [comparefn (if (null? args) (void) (car args))])
                                             (define (SortCompare j k)
                                               (let ([j-key (any->property-name j)]
                                                     [k-key (any->property-name k)])
                                                 (let ([has-j? (has-property? this j-key)]
                                                       [has-k? (has-property? this k-key)])
                                                   (cond
                                                     [(and (not has-j?) (not has-k?)) 0]
                                                     [(not has-j?) 1]
                                                     [(not has-k?) -1]
                                                     [else
                                                      (let ([x (object-get this j-key)]
                                                            [y (object-get this k-key)])
                                                        (cond
                                                          [(and (void? x) (void? y)) 0]
                                                          [(void? x) 1]
                                                          [(void? y) -1]
                                                          [(void? comparefn)
                                                           (let ([x-str (any->string x)]
                                                                 [y-str (any->string y)])
                                                             (cond
                                                               [(string<? x-str y-str) -1]
                                                               [(string<? x-str y-str) 1]
                                                               [else 0]))]
                                                          ;; XXX: #%app it
                                                          [else (comparefn x y)
                                                                ;                                                  (call comparefn
                                                                ;                                                        (list x y)
                                                                ;                                                        (lambda (s1 s2)
                                                                ;                                                          (raise-runtime-type-error here s1 s2)))
                                                                ]))]))))
                                             (define (quicksort! p r)
                                               ;(fprintf (current-error-port) "quicksort! ~a ~a~n" p r)
                                               (when (< p r)
                                                 (let ([q (partition! p r)])
                                                   (quicksort! p q)
                                                   (quicksort! (add1 q) r))))
                                             ;; TODO: randomized-partition!
                                             (define (partition! p r)
                                               (define (loop i j)
                                                 (let ([j (let drop-top ([j j])
                                                            (let ([cmp (any->integer (SortCompare j p))])
                                                              (if (or (zero? cmp) (negative? cmp)) j (drop-top (sub1 j)))))]
                                                       [i (let raise-bottom ([i i])
                                                            (let ([cmp (any->integer (SortCompare i p))])
                                                              (if (or (zero? cmp) (positive? cmp)) i (raise-bottom (add1 i)))))])
                                                   (if (< i j)
                                                       (begin (swap! i j)
                                                              (loop i j))
                                                       j)))
                                               (loop (sub1 p) (add1 r)))
                                             (define (swap! i j)
                                               (let ([i-key (any->property-name i)]
                                                     [j-key (any->property-name j)])
                                                 (let ([has-i? (has-property? this i-key)]
                                                       [has-j? (has-property? this j-key)])
                                                   (cond
                                                     [(and (not has-i?) (not has-j?)) (void)]
                                                     [(not has-i?)
                                                      (let ([j-val (object-get this j-key)])
                                                        (object-delete! this j-key)
                                                        (object-put! this i-key j-val))]
                                                     [(not has-j?)
                                                      (let ([i-val (object-get this i-key)])
                                                        (object-delete! this i-key)
                                                        (object-put! this j-key i-val))]
                                                     [else
                                                      (let ([i-val (object-get this i-key)]
                                                            [j-val (object-get this j-key)])
                                                        (object-put! this i-key j-val)
                                                        (object-put! this j-key i-val))]))))
                                             (let ([len (object-get this 'length (lambda () 0) any->uint32)])
                                               (quicksort! 0 (sub1 len))
                                               this)))))
    ;; 15.4.4.12
    (splice             ,(build-function 2
                                         (lambda args
                                           (let* ([this (current-this)]
                                                  [len (object-get this 'length (lambda () 0) any->uint32)]
                                                  [A (as-if-by-new-Array)])
                                             (let-values ([(start deleteCount items)
                                                           (match args
                                                             [(list) (values 0 0 null)]
                                                             [(list start) (values (any->integer start) 0 null)]
                                                             [(list start deleteCount items ...)
                                                              (values (any->integer start)
                                                                      (any->integer deleteCount)
                                                                      items)])])
                                               (let* ([start (if (negative? start) ;; 5
                                                                 (max (+ len start) 0)
                                                                 (min start len))]
                                                      [deleteCount (min (max deleteCount 0) (- len start))]) ;; 6
                                                 ;; 7 - 15
                                                 (for ([k (in-range 0 deleteCount)])
                                                   (let ([key (any->property-name (+ start k))])
                                                     (when (has-property? this key)
                                                       (object-put! A (any->property-name k) (object-get this key)))))
                                                 ;; 16
                                                 (object-put! A 'length deleteCount)
                                                 (let* ([insertCount (length items)] ;; 17
                                                        [newLength (+ (- len deleteCount) insertCount)])
                                                   ;; 18 - 19
                                                   (cond
                                                     [(< insertCount deleteCount)
                                                      ;; 20 - 30
                                                      (for ([k (in-range start (- len deleteCount))])
                                                        (let ([from-key (any->property-name (+ k deleteCount))]
                                                              [to-key (any->property-name (+ k insertCount))])
                                                          (if (has-property? this from-key)
                                                              (object-put! this to-key (object-get this from-key))
                                                              (object-delete! this to-key))))
                                                      ;; 31 - 36
                                                      (for ([k (in-range len newLength)])
                                                        (object-delete! this (any->property-name (sub1 k))))]
                                                     [(> insertCount deleteCount)
                                                      ;; 37 - 47
                                                      (for ([k (in-range (- len deleteCount) start -1)])
                                                        (let ([from-key (any->property-name (+ k (sub1 deleteCount)))]
                                                              [to-key (any->property-name (+ k (sub1 insertCount)))])
                                                          (if (has-property? this from-key)
                                                              (object-put! this to-key (object-get this from-key))
                                                              (object-delete! this to-key))))])
                                                   ;; 48 - 52
                                                   (for ([item items]
                                                         [k (in-range start (+ start insertCount))])
                                                     (object-put! this (any->property-name k) item))
                                                   ;; 53
                                                   (object-put! this 'length newLength)
                                                   ;; 54
                                                   A)))))))
    ;; 15.4.4.13
    (unshift            ,(build-function 1
                                         (lambda args
                                           (let* ([this (current-this)]
                                                  [len (object-get this 'length (lambda () 0) any->uint32)] ;; 2
                                                  [count (length args)]) ;; 3
                                             ;; 4 - 14
                                             (for ([k (in-range len 0 -1)])
                                               (let ([from-key (any->property-name (sub1 k))] ;; 6
                                                     [to-key (any->property-name (+ count (sub1 k)))]) ;; 7
                                                 (if (has-property? this from-key)
                                                     (object-put! this to-key (object-get this from-key))
                                                     (object-delete! this to-key))))
                                             ;; 15 - 20
                                             (for ([item args]
                                                   [k (in-range 0 count)])
                                               (object-put! this (any->property-name k) item))
                                             (let ([new-len (+ len count)])
                                               ;; 21
                                               (object-put! this 'length new-len)
                                               new-len)))))
    ))

(define String-statics
  `(;; 15.5.3.2
    (fromCharCode       ,(build-function 1
                                         (lambda args
                                           (list->string
                                            (map (compose integer->char any->uint16) args)))))
    ))

(define (show-wrapper write?)
  (build-function 1
                  (lambda args
                    (let ([this (current-this)]
                          [out (if (null? args) (current-output-port) (car args))]
                          [show (if write? write display)])
                      (cond
                        [(wrapper? this)
                         (show (wrapper-value this) out)]
                        [(object? this)
                         (display "[object Object]" out)]
                        [else
                         (show this out)])))))

(define write-wrapper (show-wrapper #t))
(define display-wrapper (show-wrapper #f))

(define String-methods
  `((write              ,write-wrapper)
    (display            ,display-wrapper)
    ;; 15.5.4.2
    (toString           ,(build-function 0
                                         (lambda args
                                           (current-this))))
    ;; 15.5.4.3
    (valueOf            ,(build-function 0 (lambda args
											  (let ((this (current-this)))
											    (if (wrapper? this)
												  (wrapper-value this)
												  this)))))
    ;; 15.5.4.4
    (charAt             ,(build-function 0 (lambda args
											  (let ((this (current-this)))
											    (string
												  (if (wrapper? this)
													(string-ref (wrapper-value this) (car args))
													(string-ref this (car args))))))))
    ;; 15.5.4.5
    (charCodeAt         ,(tmp:stub 1 "charCodeAt"))
    ;; 15.5.4.6
    (concat             ,(tmp:stub 1 "concat"))
    ;; 15.5.4.7
    (indexOf            ,(tmp:stub 1 "indexOf"))
    ;; 15.5.4.8
    (lastIndexOf        ,(tmp:stub 1 "lastIndexOf"))
    ;; 15.5.4.9
    (localeCompare      ,(tmp:stub 1 "localeCompare"))
    ;; 15.5.4.10
    (match              ,(tmp:stub 1 "match"))
    ;; 15.5.4.11
    (replace            ,(tmp:stub 2 "replace"))
    ;; 15.5.4.12
    (search             ,(tmp:stub 1 "search"))
    ;; 15.5.4.13
    (slice              ,(tmp:stub 2 "slice"))
    ;; 15.5.4.14
    (split              ,(tmp:stub 2 "split"))
    ;; 15.5.4.15
    (substring          ,(tmp:stub 2 "substring"))
    ;; 15.5.4.16
    (toLowerCase        ,(tmp:stub 0 "toLowerCase"))
    ;; 15.5.4.17
    (toLocaleLowerCase  ,(tmp:stub 0 "toLocaleLowerCase"))
    ;; 15.5.4.18
    (toUpperCase        ,(tmp:stub 0 "toUpperCase"))
    ;; 15.5.4.19
    (toLocaleUpperCase  ,(tmp:stub 0 "toLocaleUpperCase"))
	;;AML: Hack this should not be a function
    (length             ,(build-function 0 (lambda args
											  (let ((this (current-this)))
												 (if (wrapper? this)
												   (string-length (wrapper-value this))
												   (string-length this))))))
    ))

(define Boolean-methods
  `((write              ,write-wrapper)
    (display            ,display-wrapper)
    ;; 15.6.4.2
    (toString           ,(tmp:stub 0 "toString"))
    ;; 15.6.4.3
    (valueOf            ,(tmp:stub 0 "valueOf"))
    ))

(define Number-statics
  `(;; 15.7.3.2
    (MAX_VALUE          ,1.7976931348623157e308 ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?))
    ;; 15.7.3.3
    (MIN_VALUE          ,5e-324               ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?))
    ;; 15.7.3.4
    (NaN                +nan.0                ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?))
    ;; 15.7.3.5
    (NEGATIVE_INFINITY  -inf.0                ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?))
    ;; 15.7.3.6
    (POSITIVE_INFINITY  +inf.0                ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?))
    ))

(define Number-methods
  `((write              ,write-wrapper)
    (display            ,display-wrapper)
    ;; 15.7.4.2
    (toString           ,(tmp:stub 0 "toString"))
    ;; 15.7.4.3
    (toLocaleString     ,(tmp:stub 0 "toLocaleString"))
    ;; 15.7.4.4
    (valueOf            ,(tmp:stub 0 "valueOf"))
    ;; 15.7.4.5
    (toFixed            ,(tmp:stub 1 "toFixed"))
    ;; 15.7.4.6
    (toExponential      ,(tmp:stub 1 "toExponential"))
    ;; 15.7.4.7
    (toPrecision        ,(tmp:stub 1 "toPrecision"))
    ))

;; 15.8.1
(define Math-static-properties
  `(;; 15.8.1.1
    (E                  ,(exp 1)              ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.2
    (LN10               ,(log 10)             ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.3
    (LN2                ,(log 2)              ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.4
    (LOG2E              ,(/ 1 (log 2))        ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.5
    (LOG10E             ,(/ 1 (log 10))       ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.6
    (PI                 ,pi                   ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.7
    (SQRT1_2            ,(sqrt 1/2)           ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.8
    (SQRT_2             ,(sqrt 2)             ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ))

(define-syntax number-function
  (syntax-rules ()
    ((number-function name)
     (build-function 1
                     (lambda ([arg (void)] . _)
                       (name (any->number arg)))))))

;; 15.8.2
(define Math-static-methods
  `(;; 15.8.2.1
    (abs ,(number-function abs))
    ;; 15.8.2.2
    (acos ,(number-function acos))
    ;; 15.8.2.3
    (asin ,(number-function asin))
    ;; 15.8.2.4
    (atan ,(number-function atan))
    ;; 15.8.2.5
    (atan2 ,(tmp:stub 2 "atan2"))
    ;; 15.8.2.6
    (ceil ,(number-function ceiling))
    ;; 15.8.2.7
    (cos ,(number-function cos))
    ;; 15.8.2.8
    (exp ,(number-function exp))
    ;; 15.8.2.9
    (floor ,(number-function floor))
    ;; 15.8.2.10
    (log ,(number-function log))
    ;; 15.8.2.11
    (max ,(build-function 2
                          (lambda ([arg0 -inf.0] . args)
                            (apply max (any->number arg0) (map any->number args)))))
    ;; 15.8.2.12
    (min ,(build-function 2
                          (lambda ([arg0 +inf.0] . args)
                            (apply min (any->number arg0) (map any->number args)))))
    ;; 15.8.2.13
    (pow ,(build-function 2
                          (lambda ([arg0 (void)] [arg1 (void)] . args)
                            (expt (any->number arg0) (any->number arg1)))))
    ;; 15.8.2.14
    (random ,(build-function 0
                             (lambda args
                               (random))))
    
    (randomSeed ,(build-function 1
                                 (lambda (arg0 . args)
                                   (random-seed arg0))))
    ;; 15.8.2.15
    (round ,(number-function round))
    ;; 15.8.2.16
    (sin ,(number-function sin))
    ;; 15.8.2.17
    (sqrt ,(number-function sqrt))
    ;; 15.8.2.18
    (tan ,(number-function tan))
    ))

(define global-properties
  `(;; 15.1.1.1
    (NaN                +nan.0                ,(bit-field DONT-ENUM? DONT-DELETE?))
    ;; 15.1.1.2
    (Infinity           +inf.0                ,(bit-field DONT-ENUM? DONT-DELETE?))
    ;; 15.1.1.3
    (undefined          ,(void)               ,(bit-field DONT-ENUM? DONT-DELETE?))
    ))

(define eval-ref
  (let ([state js:eval])
    (make-ref (lambda () state)
              (lambda (val)
                (set! state val)
                (original-eval? (eq? val js:eval))
                val)
              (lambda () #t))))

(define global-methods
  `(;; 15.1.2.1
    (eval               ,eval-ref             ,(bit-field DONT-DELETE?))
    ;; 15.1.2.2
    (parseInt           ,js:parseInt)
    ;; 15.1.2.3
    (parseFloat         ,js:parseFloat)
    ;; 15.1.2.4
    (isNaN              ,js:isNaN)
    ;; 15.1.2.5
    (isFinite           ,js:isFinite)
    ;; 15.1.3.1
    (decodeURI          ,js:decodeURI)
    ;; 15.1.3.2
    (decodeURIComponent ,js:decodeURIComponent)
    ;; 15.1.3.3
    (encodeURI          ,js:encodeURI)
    ;; 15.1.3.4
    (encodeURIComponent ,js:encodeURIComponent)
    ))

(define global-custom-properties
  `((it                 ,(void)               ,(bit-field DONT-ENUM? DONT-DELETE?))
    ))

(define global-custom-methods
  `(;; 15
    (print              ,js:print)
    ))

(define Trace-methods
  `((toString           ,(build-function 0
                                         (lambda args
                                           (object-descriptor (current-this)))))
    (trace              ,(build-function 2
                                         (case-lambda
                                           [() (void)]
                                           [(x) (void)]
                                           [(x thunk . rest)
                                            (let ([this (current-this)])
                                              ;; XXX: check descendant of Trace
                                              (unless (wrapper? this)
                                                (raise-runtime-type-error here "Trace" "object"))
                                              (unless (procedure? thunk)
                                                (raise-runtime-type-error here "function" "?"))
                                              (with-continuation-mark (wrapper-value this) x
                                                (thunk)))])))
    (toArray            ,(build-function 0
                                         (lambda args
                                           (let ([this (current-this)])
                                             ;; XXX: check descendant of Trace
                                             (unless (wrapper? this)
                                               (raise-runtime-type-error here "Trace" "object"))
                                             (list->array
                                              (continuation-mark-set->list
                                               (current-continuation-marks)
                                               (wrapper-value this)))))))
    ))

;; XXX: this toString binding should exist in the primordial prototype object

(define Name-methods
  `((toString           ,(build-function 0
                                         (lambda args
                                           (object-descriptor (current-this)))))
    ))

(define (install-properties! object properties)
  (for-each (lambda (property)
              (match property
                [(list name value)
                 (object-put! object name value (bit-field DONT-ENUM?))]
                [(list name value attributes)
                 (object-put! object name value attributes)]))
            properties))

(define installation-cache (make-hasheq))

(define (install-standard-library-once! global)
  (hash-ref installation-cache global (lambda ()
                                        (hash-set! installation-cache global #f)
                                        (install-standard-library! global)
                                        #t)))

(define (install-standard-library! global)
  (reset-global-object! global)
  (reset-primitive-constructors! global)
  
  (install-properties! global         global-properties)
  (install-properties! global         global-methods)
  (install-properties! global         global-custom-properties)
  (install-properties! global         global-custom-methods)
  
  ;;AML
  (install-properties! global         global-rosetta-methods)
  
  (install-properties! proto:Object   Object-methods)
  (install-properties! proto:Function Function-methods)
  (install-properties! proto:Array    Array-methods)
  (install-properties! String         String-statics)
  (install-properties! proto:String   String-methods)
  (install-properties! proto:Boolean  Boolean-methods)
  (install-properties! Number         Number-statics)
  (install-properties! proto:Number   Number-methods)
  (install-properties! Math           Math-static-properties)
  (install-properties! Math           Math-static-methods)
  (install-properties! proto:Trace    Trace-methods)
  (install-properties! proto:Name     Name-methods)
  
  (current-this global)
  (original-eval? #t)
  global)


;(define (make-sphere r)
;  (sphere r))

;(define (rosetta-evaluate node)
;  (evaluate node))

;(define (rosetta-evaluate-toplevel node)
;  (evaluate-toplevel node))

#;(define global-rosetta-methods
    `(
      (backend             ,backend)
      (evaluate            ,rosetta-evaluate)
      (evaluateToplevel    ,rosetta-evaluate-toplevel)
      (sphere              ,sphere)
      (sph                 ,sph)
      (move                ,move)
      ))

;(dynamic-require 'rosetta '*2)

(define (javascriptize-symbol sym)
  ; (printf "~a->~a~%" sym (string->symbol (javascriptize-string (symbol->string sym))))
  (string->symbol (javascriptize-string (symbol->string sym))))

(define (javascriptize-string str)
  (let ((words (map javascriptize-word (regexp-split "-" str))))
    (string-append* (first words)
                    (map string-mytitlecase (rest words)))))

(define (string-mytitlecase str)
  (if (> (string-length str) 0)
      (let ((str (string-copy str)))
        (string-set! str 0 (char-upcase (string-ref str 0)))
        str)
      str))

(define (javascriptize-word str)
  (string-append* (map (lambda (c)
                         (case c
                           ((#\*) "Star")
                           ((#\+) "Plus")
                           ((#\?) "P")
                           ((#\!) "N")
                           (else (string c))))
                       (string->list str))))

(define (install-racket-module module)
  (let ((obj (current-this))
        (module (read (open-input-string module))))
    (dynamic-require module #f)
    (for-each (lambda (sym)
                (let ((value (dynamic-require module sym (lambda () #f))))
                  (when value
                    (object-put! obj (javascriptize-symbol sym) value))))
              (map first 
                   (cdr (assoc 0 (call-with-values (lambda () (module->exports module))
                                                   (lambda (v0 v1) v0))))))))

(define global-rosetta-methods
  `(
    (require ,install-racket-module)
    ))